Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/magict_1/simplewe.frm

Visual Basic Form | 1999-07-22 | 16.0 KB | 602 lines

VERSION 5.00
Object = "{3035B5D2-295D-11D3-8C54-006008BA8D16}#1.0#0"; "MAGICTCP.OCX"
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   8010
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   10080
   LinkTopic       =   "Form1"
   ScaleHeight     =   8010
   ScaleWidth      =   10080
   StartUpPosition =   3  'Windows-Standard
   Begin VB.CheckBox chkSubdirs
      Caption         =   "Enable Subdirectories"
      Height          =   255
      Left            =   8040
      TabIndex        =   25
      Top             =   240
      Width           =   1935
   End
   Begin VB.CommandButton cmdSave
      Caption         =   "Save Config"
      Height          =   495
      Left            =   8040
      TabIndex        =   24
      Top             =   1200
      Width           =   1455
   End
   Begin VB.TextBox txtLog
      Height          =   2655
      Left            =   240
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertikal
      TabIndex        =   22
      TabStop         =   0   'False
      Top             =   5280
      Width           =   9735
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   7
      Left            =   3960
      TabIndex        =   21
      Top             =   4560
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   7
      Left            =   240
      TabIndex        =   20
      Top             =   4560
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   6
      Left            =   3960
      TabIndex        =   19
      Top             =   4080
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   6
      Left            =   240
      TabIndex        =   18
      Top             =   4080
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   5
      Left            =   3960
      TabIndex        =   17
      Top             =   3600
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   5
      Left            =   240
      TabIndex        =   16
      Top             =   3600
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   4
      Left            =   3960
      TabIndex        =   15
      Top             =   3120
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   4
      Left            =   240
      TabIndex        =   14
      Top             =   3120
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   3
      Left            =   3960
      TabIndex        =   13
      Top             =   2640
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   3
      Left            =   240
      TabIndex        =   9
      Top             =   2640
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   2
      Left            =   3960
      TabIndex        =   8
      Top             =   2160
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   2
      Left            =   240
      TabIndex        =   7
      Top             =   2160
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   1
      Left            =   3960
      TabIndex        =   6
      Top             =   1680
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   1
      Left            =   240
      TabIndex        =   5
      Top             =   1680
      Width           =   3615
   End
   Begin VB.TextBox txtPhysical
      Height          =   405
      Index           =   0
      Left            =   3960
      TabIndex        =   4
      ToolTipText     =   "Corresponding physical path for virtual path to the left"
      Top             =   1200
      Width           =   3615
   End
   Begin VB.TextBox txtVirtual
      Height          =   405
      Index           =   0
      Left            =   240
      TabIndex        =   3
      ToolTipText     =   "Virtual path"
      Top             =   1200
      Width           =   3615
   End
   Begin VB.CommandButton cmdStart
      Caption         =   "Start!"
      Default         =   -1  'True
      Height          =   495
      Left            =   8040
      TabIndex        =   23
      Top             =   4440
      Width           =   1455
   End
   Begin VB.TextBox txtPort
      Height          =   375
      Left            =   600
      TabIndex        =   0
      ToolTipText     =   "TCP port where to listen"
      Top             =   240
      Width           =   855
   End
   Begin VB.TextBox txtAccessList
      Height          =   375
      Left            =   2760
      TabIndex        =   2
      ToolTipText     =   "Comma separeted list of ip adresses containing wild card '*'"
      Top             =   240
      Width           =   4815
   End
   Begin M3LibCtl.MagicTCP M1
      Left            =   8400
      OleObjectBlob   =   "SimpleWeb.frx":0000
      Top             =   2520
   End
   Begin VB.Line Line2
      X1              =   120
      X2              =   9960
      Y1              =   5160
      Y2              =   5160
   End
   Begin VB.Label Label4
      Caption         =   "Phsical Path"
      Height          =   255
      Left            =   3960
      TabIndex        =   12
      Top             =   960
      Width           =   3135
   End
   Begin VB.Label Label3
      Caption         =   "Virtual Path"
      Height          =   255
      Left            =   240
      TabIndex        =   11
      Top             =   960
      Width           =   3135
   End
   Begin VB.Line Line1
      X1              =   120
      X2              =   9960
      Y1              =   840
      Y2              =   840
   End
   Begin VB.Label Label2
      Caption         =   "Access List"
      Height          =   375
      Left            =   1800
      TabIndex        =   10
      Top             =   240
      Width           =   855
   End
   Begin VB.Label Label1
      Caption         =   "Port"
      Height          =   255
      Left            =   240
      TabIndex        =   1
      Top             =   240
      Width           =   375
   End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const MAX_VPATHS = 8
Dim ServerSocket As Long
Dim ServerPort As Long
Dim AccessList As String
Dim serverSubdirs As Long
Dim vPath(1 To 8) As String ' our virtual paths
Dim pPath(1 To 8) As String ' corresponding physical paths
Sub CloseSocket()
With M1
    If .zzState >= 0 Then
        Close .zzState
    End If
    .Delete .CurrentSocket
End With
End Sub
Sub HttpError(c As Integer, t As String)
' return an http error
Dim s As String
Dim r As String
Dim n As Long
With M1
    r = "Error: " & t
    s = "HTTP/1.0 " & CStr(c) & " " & t & vbCrLf
    s = s & "Content-Type: text/plain" & vbCrLf
    s = s & "Content-Length: " & CStr(Len(r)) & vbCrLf
    s = s & vbCrLf
    s = s & r
    n = .WriteString(s)
    If (n > 0) And (n < Len(s)) Then
        .zzBuffer = Mid$(s, n + 1)
    End If
End With
End Sub
Function IsPostfix(s As String, p As String) As Boolean
Dim tf As Boolean
If Len(p) = 0 Then
    tf = True
    If (Len(s) = 0) Or (Len(s) < Len(p)) Then
        tf = False
    Else
        tf = Mid$(s, Len(s) - Len(p) + 1) = p
    End If
End If
IsPostfix = tf
End Function
Sub LoadConfig()
' load config from inifile
Dim i As Integer
Dim k As String
Dim v As String
Dim p As String
Dim c As Integer
With M1
    For i = 1 To MAX_VPATHS
        k = "VPATH" & CStr(i)

        v = .GetProfileString("MAPPING", k, "")
        v = Trim$(v)

        If v <> "" Then
            p = .GetProfileString("MAPPING", v, "")
            p = Trim$(p)
        End If

        If (v <> "") And (p <> "") Then
            If Not IsPostfix(v, "/") Then
                v = v & "/"
            End If

            If Not IsPostfix(p, "\") Then
                p = p & "\"
            End If

            vPath(i) = v
            pPath(i) = p

            txtVirtual(i - 1) = v
            txtPhysical(i - 1) = p
        End If
    Next i
    ServerPort = .GetProfileInt("CONFIG", "PORT", 80)
    txtPort = CStr(ServerPort)
    AccessList = .GetProfileString("CONFIG", "ACCESSLIST", "")
    txtAccessList = AccessList
    serverSubdirs = CInt(.GetProfileInt("CONFIG", "SUBDIRS", 0))
    chkSubdirs = serverSubdirs
    cmdSave.Enabled = False
End With
End Sub
Function MapPath(vp As String) As String
' find physical path for a given path
Dim i As Integer
Dim pd As String
Dim tf As Boolean
i = 1
tf = False
pd = ""
While (i < MAX_VPATHS) And Not tf
    If vp = vPath(i) Then
        tf = True
        pd = pPath(i)
    Else
        i = i + 1
    End If
MapPath = pd
End Function
Function OpenFile(path As String) As Boolean
' open requested file
Dim i As Integer
Dim tf As Boolean
Dim vp As String
Dim pd As String
Dim fn As String
Dim ct As String
Dim s As String
On Error GoTo O_ERR
tf = True
If tf Then
    i = InStrRev(path, "/")
    If (i = 0) Then
        tf = False
    End If
End If
' get the physical path and filename
If tf Then
    tf = False
    Do
        vp = Left$(path, i)
        pd = MapPath(vp)
        tf = Len(pd) > 0
        If Not tf Then
            path = Left$(path, i - 1) & "\" & Mid$(path, i + 1)
            i = i - 1
            If (i > 0) Then
                i = InStrRev(path, "/", i)
            End If
        End If
    Loop While Not tf And (i > 0) And serverSubdirs
    If tf Then
       fn = Mid$(path, i + 1)
    End If
End If
' test if file can be found
If tf Then
    fn = pd & fn
    tf = (Dir$(fn) <> "")
End If
If tf Then
    ' get mime type
    i = InStr(fn, ".")
    If i > 0 Then
        ct = Mid$(fn, i + 1)
    Else
        ct = ""
    End If
    Select Case LCase$(ct)
        Case "htm", "html"
            ct = "text/html"

        Case "jpg", "jpeg"
            ct = "image/jpeg"

        Case "gif"
            ct = "image/gif"

        Case Else
            ct = M1.GetProfileString("CONTENT-TYPES", ct, "")
            If ct = "" Then
                ct = "text/plain"
            End If
    End Select
    ' response header
    s = "HTTP/1.0 200 OK" & vbCrLf
    s = s & "Content-Type: " & ct & vbCrLf
    s = s & "Content-Length: " & FileLen(fn) & vbCrLf
    s = s & vbCrLf
    ' write header to browser
    i = M1.WriteString(s)
    tf = (i = Len(s))
End If
If tf Then
    tf = M1.WriteFile(fn)
End If
O_EXIT:
    If Not tf Then
        HttpError 404, "File not found"
    End If
    OpenFile = tf
    Exit Function
O_ERR:
    tf = False
    MsgBox Err.Description
    Resume O_EXIT
End Function
Sub SaveConfig()
' Save configuration to inifile
Dim i As Integer
Dim k As String
Dim v As String
Dim p As String
With M1
    For i = 1 To MAX_VPATHS
        v = Trim$(txtVirtual(i - 1))
        p = Trim$(txtPhysical(i - 1))

        If (v <> "") And (p <> "") Then
            k = "VPATH" & CStr(i)
            .SetProfileString "MAPPING", k, v
            .SetProfileString "MAPPING", v, p
        End If
    Next i
    .SetProfileInt "CONFIG", "PORT", CLng(txtPort)
    .SetProfileString "CONFIG", "ACCESSLIST", LTrim$(RTrim$(txtAccessList))
    .SetProfileInt "CONFIG", "SUBDIRS", CLng(chkSubdirs)
    cmdSave.Enabled = False
End With
End Sub
Function Split(ByRef s As String, d As String) As String
Dim i As Integer
i = InStr(s, d)
If (i = 0) Then
    Split = s
    s = ""
    Split = Left$(s, i - 1)
    s = Mid$(s, i + Len(d))
End If
End Function
Sub StartStop()
With M1
    ' Active socket?
    If .IsValidSocket(ServerSocket) Then
        ' stop server
        .Delete ServerSocket
        cmdStart.Caption = "Start!"
    Else
        ' create a new socket for listening
        ServerSocket = .New
        .CurrentSocket = ServerSocket

        ' Transfer attributes from configuration
        .LocalPort = CLng(txtPort)
        .ReUseAddr = True
        .AccessList = AccessList

        ' start listening for incoming connection requests
        If Not .Listen Then
            MsgBox "Cannot start server: " & .LastErrorText
            .Delete ServerSocket
        Else
            cmdStart.Caption = "Stop!"
        End If
    End If
End With
End Sub
Private Sub chkSubdirs_Click()
cmdSave.Enabled = True
End Sub
Private Sub cmdSave_Click()
If MsgBox("Save Configuration", vbYesNo Or vbQuestion) = vbYes Then
    SaveConfig
    LoadConfig
End If
End Sub
Private Sub cmdStart_Click()
StartStop
End Sub
Private Sub Form_Load()
' No Server Socket
ServerSocket = -1
' LoadConfig
LoadConfig
' Start HTTP-Service
StartStop
End Sub
Private Sub M1_OnClose()
CloseSocket
End Sub
Private Sub M1_OnError(ByVal WinsockError As Long, ByVal Func As String)
CloseSocket
End Sub
Private Sub M1_OnFileWritten(ByVal Success As Boolean, ByVal Filename As String)
CloseSocket
End Sub
Private Sub M1_OnRead()
Dim tf As Boolean
Dim take As Boolean
Dim done As Boolean
Dim s As String
Dim method As String
Dim path As String
Dim version As String
Dim i As Integer
With M1
    take = False
    done = False
    ' read line from browser
    tf = .ReadString(s)
    If tf Then
        ' merge data already read and new data
        s = .zzBuffer & s

        ' request line is terminated by CR LF
        i = InStr(s, vbCrLf)
        take = i > 0
        If Not take Then
            ' line not complete, store data read so far
            .zzBuffer = s
        End If
    End If
    If tf And take Then
        ' log request
        s = Left$(s, i - 1)
        txtLog = txtLog & .RemoteHost & ":" & .RemotePort & " " & s & vbCrLf
        txtLog.SelStart = Len(txtLog) + 1

        .zzBuffer = ""

        method = Split(s, " ")
        path = Split(s, " ")
        version = Split(s, " ")

        ' only GET method ist accepted
        If method <> "GET" Then
            HttpError 400, method & " not supported"
            done = True
        End If
    End If
    If tf And take And Not done Then
        ' open file for transfer
        done = Not OpenFile(path)
    End If
    'If tf And take And Not done Then
        ' start writing to browser
    '    done = Not WriteFile
    'End If
    If done Or Not tf Then
        ' close on error
        CloseSocket
    End If
End With
End Sub
Private Sub txtAccessList_Change()
cmdSave.Enabled = True
End Sub
Private Sub txtPhysical_Change(Index As Integer)
cmdSave.Enabled = True
End Sub
Private Sub txtPort_Change()
cmdSave.Enabled = True
End Sub
Private Sub txtVirtual_Change(Index As Integer)
cmdSave.Enabled = True
End Sub